home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
Modules
/
describe.em
< prev
next >
Wrap
Lisp/Scheme
|
1992-10-06
|
3KB
|
110 lines
;;; describe various objects
;;; version 1.0
;;; RJB May 92
(defmodule describe
((rename ((function-lambda-list fll)) standard0))
()
; first fix fll
(defgeneric function-lambda-list (fun))
(defmethod function-lambda-list ((f object))
(fll f))
(defmethod function-lambda-list ((gf generic-function))
(let ((meths (generic-function-methods gf)))
(if (atom meths)
"unknown"
(mkargs (length (method-signature (car meths)))))))
(defmethod function-lambda-list ((c continuation))
'(a))
(defun mkargs (n)
(if (= n 0) ()
(cons (vector-ref #(@ a b c d e f g h i j k l m n o
p q r s t u v w x y z) n)
(mkargs (- n 1)))))
(defgeneric describe (obj))
(defmethod describe ((cl class))
(format t "The class ~a is an instance of ~a~%"
cl (class-of cl))
(format t "class precedence list: ~a~%"
(class-precedence-list cl))
(format t "direct superclasses: ~a~%"
(class-direct-superclasses cl))
(format t "direct subclasses: ~a~%"
(class-direct-subclasses cl))
(when (class-direct-slot-descriptions cl)
(format t "direct slots~%------------~%")
(mapcar describe-slot
(class-direct-slot-descriptions cl)))
; (when (class-constructors cl)
; (format t "------------~%")
; (format t "class constructors:~%")
; (mapcar print (class-constructors cl)))
t)
(defmethod describe ((inst object))
(format t "~a is an instance of ~a~%"
inst (class-of inst))
(describe-slot-values (class-direct-slot-descriptions (class-of inst))
inst)
t)
(defun describe-slot (sl)
(format t "slot name: ~a~%"
(slot-description-name sl))
(format t "position: ~a~%"
(slot-description-position sl))
(format t "initargs: ~a~%"
(slot-description-initargs sl)))
(defun describe-slot-values (slotds inst)
(when slotds
(let ((name (slot-description-name (car slotds))))
(format t "slot ~a: ~a~%"
name
(slot-value inst name))
(describe-slot-values (cdr slotds) inst))))
(defmethod describe ((f function))
(call-next-method)
(format t "argument list: ~a~%" (function-lambda-list f))
t)
(defmethod describe ((gf generic-function))
(call-next-method)
(format t "methods signatures:~%")
(mapcar (lambda (m)
(format t "~a~%" (method-signature m)))
(generic-function-methods gf))
t)
(defmethod describe ((m method))
(call-next-method)
; (format t "generic function: ~a~%" (method-generic-function m))
(format t "signature: ~a~%" (method-signature m))
t)
(defmethod describe ((th thread))
(call-next-method)
(format t "thread state: ~a~%" (thread-state th))
t)
(defmethod describe ((sl slot-description))
(call-next-method)
(describe-slot sl)
t)
; semaphores
(export describe)
)